home *** CD-ROM | disk | FTP | other *** search
/ CICA 1993 April / CICA MS Windows - April 1993.iso / unzipped / programr / tp / custom / custom.pas < prev   
Pascal/Delphi Source File  |  1991-07-24  |  24KB  |  847 lines
  1. {************************************************************************
  2. *
  3. *    Custom Controls Unit
  4. *
  5. *    WRITTEN BY:        Shawn Aubrey Baker (aka sab)
  6. *
  7. *    COMPUSERVE ID:    76450,22
  8. *
  9. *    CREDITS:            This code started out being based on the work of
  10. *                        Robert Norton, who uploaded a bitmap button unit to
  11. *                        Compuserve. Thanks Robert, it helped a lot. Also, the
  12. *                        code from the example unit (BITBTN.PAS) that came with
  13. *                        Turbo Pascal for Windows was a big help. Thanks Borland.
  14. *
  15. *    USE:                As you wish. Please send any comments and/or bug fixes
  16. *                        via mail to the above ID. IF IT DIES IT'S YOUR PROBLEM.
  17. *
  18. *    NOTES:            This file uses tabs = 3
  19. *
  20. *    THE PROBLEM:    The first time I tried this the custom bitmap buttons
  21. *                        worked fine in a TWindow but died a horrible death in
  22. *                        a TDlgWindow. This is because Windows creates the
  23. *                        actual controls instead of OWL. OWL provides little
  24. *                        (read NO) support for custom controls and assumes that
  25. *                        any control from a resource is fully created by the time
  26. *                        that OWL gets to its child window creation code. This
  27. *                        means that OWL doesn't try to create the window (good!)
  28. *                        but that it has installed set the window procedure to
  29. *                        its standard initialization proc (bad!). This procedure
  30. *                        (InitWndProc for those with the OWL source) depends on
  31. *                        having a global variable (CreationWindow) set that points
  32. *                        to the object being created. Since this variable hasn't
  33. *                        been set the routine goes off into la-la land. Also, the
  34. *                        InitResource method sets the DefaultProc pointer to nil,
  35. *                        which again causes OWL to go astray.
  36. *
  37. *    THE SOLUTION:    The method I've used to get around this is to override
  38. *                        the window procedure pointer in the TWndClass structure
  39. *                        to point my own procedure (InitCustom). Unfortunately,
  40. *                        the InitCustom procedure needs to get a pointer to the
  41. *                        object being initialized in order to get the real window
  42. *                        procedure out of the Instance variable. Therefore, I've
  43. *                        had to create a collection of custom controls and get
  44. *                        the pointers out of there. Again, this only applies to
  45. *                        controls from resources, so the object is added to the
  46. *                        collection in InitResource and removed from it in
  47. *                        InitCustom. It is possible to get into problems with this
  48. *                        if you Init 2 dialogs with custom controls before you
  49. *                        ExecDialog either of them. If there is a TCustom control
  50. *                        with the same ID in the two resources then there is no
  51. *                        telling which one will get picked out of the collection.
  52. *                        It's simple, DON'T DO THIS!!!
  53. *
  54. *                        As far as the TWindow.InitResource problem goes, I simply
  55. *                        call TWindow.Init as it does and then set everything
  56. *                        except the DefaultProc pointer in the same way as
  57. *                        TWindow.InitResource does.
  58. *
  59. *    THE END.
  60. *
  61. ************************************************************************}
  62.  
  63. unit    Custom;
  64.  
  65. interface
  66.  
  67. uses    WinTypes,WinProcs,WObjects,Strings;
  68.  
  69. type
  70.  
  71.         PCustom=^TCustom;
  72.         TCustom=object(TWindow)
  73.             constructor    Init(AParent:PWindowsObject; AnId:integer;
  74.                                     ATitle:PChar; X,Y,W,H:integer);
  75.             constructor    InitResource(AParent:PWindowsObject; AnID:word);
  76.             procedure    SetupWindow; virtual;
  77.             function        GetClassName:PChar; virtual;
  78.             procedure    GetWindowClass(var AWndClass:TWndClass); virtual;
  79.             end;
  80.  
  81.         PCustomButton=^TCustomButton;
  82.         TCustomButton=object(TCustom)
  83.             OwnMouse        :    boolean;        { Is the mouse held captive?            }
  84.             Pressed        :    boolean;        { Is the button currently pressed?    }
  85.             Default        :    boolean;        { Is this the default button?            }
  86.  
  87.             constructor    Init(AParent:PWindowsObject; AnID:integer;
  88.                                     AText:PChar; X,Y,W,H:integer; IsDefault:boolean);
  89.             constructor    InitResource(AParent:PWindowsObject; AnID:integer);
  90.             procedure    SetupWindow; virtual;
  91.  
  92.             procedure    WMMouseMove(var Msg:TMessage);
  93.                                                     virtual wm_First + wm_MouseMove;
  94.  
  95.             procedure    WMLButtonDown(var Msg:TMessage);
  96.                                                     virtual wm_First + wm_LButtonDown;
  97.             procedure    WMLButtonUp(var Msg:TMessage);
  98.                                                     virtual wm_First + wm_LButtonUp;
  99.  
  100.             procedure    WMSetFocus(var Msg:TMessage);
  101.                                                     virtual wm_First + wm_SetFocus;
  102.             procedure    WMKillFocus(var Msg:TMessage);
  103.                                                     virtual wm_First + wm_KillFocus;
  104.  
  105.             procedure    WMKeyDown(var Msg:Tmessage);
  106.                                                     virtual wm_First + wm_KeyDown;
  107.             procedure    WMKeyUp(var Msg:Tmessage);
  108.                                                     virtual wm_First + wm_KeyUp;
  109.  
  110.             procedure    WMGetDlgCode(var Msg:Tmessage);
  111.                                                     virtual wm_First + wm_GetDlgCode;
  112.             procedure    BMSetStyle(var Msg:Tmessage);
  113.                                                     virtual wm_First + bm_SetStyle;
  114.             end;
  115.  
  116.         PBitButton=^TBitButton;
  117.         TBitButton=object(TCustomButton)
  118.             UpBits        :    HBitMap;
  119.             FocUpBits    :    HBitMap;
  120.             DownBits        :    HBitMap;
  121.             UpName        :    PChar;
  122.             FocUpName    :    PChar;
  123.             DownName        :    PChar;
  124.             bmWidth        :    integer;
  125.             bmHeight        :    integer;
  126.  
  127.             constructor    Init(AParent:PWindowsObject; AnID,X,Y:integer;
  128.                                     AUpName,AFocUpName,ADownName:PChar;
  129.                                     IsDefault:boolean);
  130.             constructor    InitResource(AParent:PWindowsObject; AnID:integer;
  131.                                                 AUpName,AFocUpName,ADownName:PChar);
  132.             destructor    Done; virtual;
  133.             procedure    SetupWindow; virtual;
  134.             function        GetClassName:PChar; virtual;
  135.             procedure    Paint(DC:HDC; var PaintInfo:TPaintStruct); virtual;
  136.             end;
  137.  
  138. implementation
  139.  
  140. {------------------------------------------------------------------------
  141. -------------------------------------------------------------------------
  142. ----                                    TCustom Object                                    ----
  143. -------------------------------------------------------------------------
  144. ------------------------------------------------------------------------}
  145.  
  146. {************************************************************************
  147. *
  148. *    Name:            InitCustom
  149. *
  150. *    Purpose:        Called with the first message for a custom control. This
  151. *                    routine sets the window procedure to the one pointed to
  152. *                    by Instance in the Custom object. The object is stored in
  153. *                    the Customs collection by the Init/InitResource routine
  154. *                    and it is removed here. This list is only needed in order
  155. *                    to find the actual object.
  156. *
  157. *    Parameters:    Message    - the first message (should be wm_NCCreate)
  158. *                    WParam    - more message info
  159. *                    LParam    - even more message info
  160. *
  161. *    Return:        window procedure return value (depends on the message command)
  162. *
  163. ************************************************************************}
  164.  
  165. var    Customs:PCollection;        { collection of custom controls }
  166.         ACustom:PWindowsObject;    { current custom control }
  167.  
  168. function InitCustom(HWindow:HWND; Message,WParam:word; LParam:longint):
  169.                             longint; export;
  170.  
  171. var    ID:longint;
  172.  
  173.         { finds the Custom object in the Customs collection }
  174.  
  175.         function FindID(Custom:PCustom):boolean; far;
  176.         begin
  177.         FindID:=Custom^.GetID = ID;
  178.         end;
  179.  
  180. begin
  181.  
  182. { find the Custom object, delete it from the collection }
  183.  
  184. ID:=GetWindowWord(HWindow,gww_ID);
  185. ACustom:=Customs^.FirstThat(@FindID);
  186. Customs^.Delete(ACustom);
  187.  
  188. { set the window proc to the instance proc }
  189.  
  190. SetWindowLong(HWindow,gwl_WndProc,longint(ACustom^.Instance));
  191.  
  192. { call the instance proc to handle the message }
  193.  
  194. asm
  195.     PUSH    HWindow
  196.     PUSH    Message
  197.     PUSH    WParam
  198.     PUSH    LParam.Word[2]
  199.     PUSH    LParam.Word[0]
  200.     MOV    AX,DS
  201.     LES    DI,ACustom
  202.     CALL    ES:[DI].TWindowsObject.Instance
  203. end;
  204.  
  205. end;
  206.  
  207. {************************************************************************
  208. *
  209. *    Name:            TCustom.Init
  210. *
  211. *    Purpose:        Initializes a custom control.
  212. *
  213. *    Parameters:    AParent        - parent window
  214. *                    AnID            - button ID
  215. *                    ATitle        - control title
  216. *                    X,Y,W,H        - position and size
  217. *
  218. *    Return:        None
  219. *
  220. ************************************************************************}
  221.  
  222. constructor TCustom.Init(AParent:PWindowsObject; AnId:integer;
  223.                                     ATitle:PChar; X,Y,W,H:integer);
  224. begin
  225. TWindow.Init(AParent,ATitle);
  226. Attr.Id:=AnId;
  227. Attr.X:=X;
  228. Attr.Y:=Y;
  229. Attr.W:=W;
  230. Attr.H:=H;
  231. Attr.Style:=ws_Child or ws_Visible or ws_Group or ws_TabStop;
  232. end;
  233.  
  234. {************************************************************************
  235. *
  236. *    Name:            TCustom.InitResource
  237. *
  238. *    Purpose:        Initializes a custom control from a resource and enables
  239. *                    data transfer.
  240. *
  241. *    Parameters:    AParent        - parent window
  242. *                    AnID            - button ID
  243. *
  244. *    Return:        None
  245. *
  246. ************************************************************************}
  247.  
  248. constructor TCustom.InitResource(AParent:PWindowsObject; AnID:word);
  249. begin
  250.  
  251. { replacement code for TWindow.InitResource, needed        }
  252. { because the TWindow routine sets DefaultProc to nil,    }
  253. { wherease TWindow.Init sets it to the routine we want    }
  254.  
  255. TWindow.Init(AParent,nil);
  256. SetFlags(wb_FromResource,true);
  257. FillChar(Attr,SizeOf(Attr),0);
  258. Attr.ID:=AnID;
  259.  
  260. { must pre-register because Windows creates controls from resources }
  261.  
  262. if not Register then Fail;
  263. EnableTransfer;
  264.  
  265. { add it to the Customs collection so that the InitCustom proc can find it }
  266.  
  267. Customs^.Insert(@self);
  268. end;
  269.  
  270. {************************************************************************
  271. *
  272. *    Name:            TCustom.SetupWindow
  273. *
  274. *    Purpose:        Sets up the window and gets the attributes if the window
  275. *                    is from a resource.
  276. *
  277. *    Parameters:    None
  278. *
  279. *    Return:        None
  280. *
  281. ************************************************************************}
  282.  
  283. procedure TCustom.SetupWindow;
  284. var    Rect:TRect;
  285.         Pt:TPoint;
  286. begin
  287. TWindow.SetupWindow;
  288.  
  289. { if it's from a resource then set the attributes }
  290.  
  291. if IsFlagSet(wb_FromResource) then
  292.     begin
  293.  
  294.     { get the client rect in screen co-ordinates }
  295.  
  296.     GetWindowRect(HWindow,Rect);
  297.     Pt.X:=Rect.Left;
  298.     Pt.Y:=Rect.Top;
  299.  
  300.     { make the position relative to the parent window }
  301.  
  302.     ScreenToClient(GetWindowWord(HWindow,gww_HWndParent),Pt);
  303.     Attr.X:=Pt.X;
  304.     Attr.Y:=Pt.Y;
  305.  
  306.     { get the client rect and set the window size }
  307.  
  308.     GetClientRect(HWindow,Rect);
  309.     Attr.W:=Rect.Right-Rect.Left;
  310.     Attr.H:=Rect.Bottom-Rect.Top;
  311.  
  312.     { get the style info }
  313.  
  314.     Attr.Style:=GetWindowWord(HWindow,gwl_Style);
  315.     Attr.ExStyle:=GetWindowWord(HWindow,gwl_ExStyle);
  316.     end;
  317. end;
  318.  
  319. {************************************************************************
  320. *
  321. *    Name:            TCustom.GetClassName
  322. *
  323. *    Purpose:        Abstract virtual method that gets the class name for a
  324. *                    custom control. Generates a run-time error to ensure
  325. *                    that the descendants override the method with their
  326. *                    own class name.
  327. *
  328. *    Parameters:    None
  329. *
  330. *    Return:        None
  331. *
  332. ************************************************************************}
  333.  
  334. function TCustom.GetClassName:PChar;
  335. begin
  336. Abstract;
  337. end;
  338.  
  339. {************************************************************************
  340. *
  341. *    Name:            TCustom.GetWindowClass
  342. *
  343. *    Purpose:        Sets the class info for a custom control. Overrides the
  344. *                    TPW startup procedure to use code that will find the
  345. *                    object in our "Customs" collection.
  346. *
  347. *    Parameters:    AWndClass - class information
  348. *
  349. *    Return:        None
  350. *
  351. ************************************************************************}
  352.  
  353. procedure TCustom.GetWindowClass(var AWndClass:TWndClass);
  354. begin
  355. TWindow.GetWindowClass(AWndClass);
  356.  
  357. if IsFlagSet(wb_FromResource) then
  358.     AWndClass.lpfnWndProc:=@InitCustom;
  359. end;
  360.  
  361. {------------------------------------------------------------------------
  362. -------------------------------------------------------------------------
  363. ----                                TCustomButton Object                                ----
  364. -------------------------------------------------------------------------
  365. ------------------------------------------------------------------------}
  366.  
  367. {************************************************************************
  368. *
  369. *    Name:            TCustomButton.Init
  370. *
  371. *    Purpose:        Initializes a custom button.
  372. *
  373. *    Parameters:    AParent        - parent window
  374. *                    AnID            - button ID
  375. *                    AText            - button text (or nil)
  376. *                    X,Y,W,H        - position and size
  377. *                    IsDefault    - default button ?
  378. *
  379. *    Return:        None
  380. *
  381. ************************************************************************}
  382.  
  383. constructor    TCustomButton.Init(AParent:PWindowsObject; AnID:integer;
  384.                                             AText:PChar; X,Y,W,H:integer;
  385.                                             IsDefault:boolean);
  386. begin
  387. TCustom.Init(AParent,AnID,nil,X,Y,10,10);
  388. if IsDefault then
  389.     Attr.Style:=Attr.Style or bs_DefPushButton
  390. else
  391.     Attr.Style:=Attr.Style or bs_PushButton;
  392. end;
  393.  
  394. {************************************************************************
  395. *
  396. *    Name:            TCustomButton.InitResource
  397. *
  398. *    Purpose:        Initializes a custom button from a resource.
  399. *
  400. *    Parameters:    AParent    - parent window
  401. *                    AnID        - button ID
  402. *
  403. *    Return:        None
  404. *
  405. ************************************************************************}
  406.  
  407. constructor    TCustomButton.InitResource(AParent:PWindowsObject; AnID:integer);
  408. begin
  409. TCustom.InitResource(AParent,AnID);
  410. DisableTransfer;
  411. end;
  412.  
  413. {************************************************************************
  414. *
  415. *    Name:            TCustomButton.SetupWindow
  416. *
  417. *    Purpose:        Sets up the window and initializes the state variables.
  418. *
  419. *    Parameters:    None
  420. *
  421. *    Return:        None
  422. *
  423. ************************************************************************}
  424.  
  425. procedure TCustomButton.SetupWindow;
  426. begin
  427. TCustom.SetupWindow;
  428.  
  429. Pressed:=false;
  430. OwnMouse:=false;
  431. Default:=Attr.Style and bs_DefPushButton = bs_DefPushButton;
  432. end;
  433.  
  434. {************************************************************************
  435. *
  436. *    Name:            TCustomButton.WMLButtonDown
  437. *
  438. *    Purpose:        repaint the button in the down position when the left
  439. *                    mouse button is pressed.
  440. *
  441. *    Parameters:    Msg - a message
  442. *
  443. *    Return:        None
  444. *
  445. ************************************************************************}
  446.  
  447. procedure TCustomButton.WMLButtonDown(var Msg:TMessage);
  448. begin
  449.  
  450. { if not already pressed then set state to pressed }
  451.  
  452. if not Pressed then
  453.     begin
  454.     if GetFocus <> hWindow then
  455.         SetFocus(hWindow);
  456.     Pressed:=true;
  457.     OwnMouse:=true;
  458.     SetCapture(hWindow);
  459.     end;
  460.  
  461. { trigger repaint }
  462.  
  463. InvalidateRect(hWindow,nil,false);
  464. end;
  465.  
  466. {************************************************************************
  467. *
  468. *    Name:            TCustomButton.WMLButtonUp
  469. *
  470. *    Purpose:        If the left mouse button is pressed and then released
  471. *                    over the button then repaint it as unpressed and notify
  472. *                    the parent window.
  473. *
  474. *    Parameters:    Msg - a message
  475. *
  476. *    Return:        None
  477. *
  478. ************************************************************************}
  479.  
  480. procedure TCustomButton.WMLButtonUp(var Msg:TMessage);
  481. begin
  482. if OwnMouse then
  483.     begin
  484.     ReleaseCapture;
  485.     OwnMouse:=false;
  486.     if Pressed then        { trigger repaint and notify parent }
  487.         begin
  488.         Pressed:=false;
  489.         InvalidateRect(hWindow,nil,false);
  490.         PostMessage(Parent^.hWindow,wm_Command,Attr.Id,longint(hWindow));
  491.         end;
  492.     end;
  493. end;
  494.  
  495. {************************************************************************
  496. *
  497. *    Name:            TCustomButton.WMMouseMove
  498. *
  499. *    Purpose:        Repaints the button when the mouse is pressed and moves
  500. *                    into and outof the button window.
  501. *
  502. *    Parameters:    Msg - a message
  503. *
  504. *    Return:        None
  505. *
  506. ************************************************************************}
  507.  
  508. procedure TCustomButton.WMMouseMove(var Msg:TMessage);
  509. var    BtnRect:TRect;
  510.         MousePt:TPoint;
  511. begin
  512.  
  513. { get window rectangle and mouse point }
  514.  
  515. GetClientRect(hWindow,BtnRect);
  516. MousePt.X:=integer(Msg.lParamLo);
  517. MousePt.Y:=integer(Msg.lParamHi);
  518.  
  519. { if the mouse is over the button }
  520.  
  521. if PtInRect(BtnRect,MousePt) then
  522.     begin
  523.  
  524.     { if the mouse is moved into the button area }
  525.  
  526.     if OwnMouse and (not Pressed) then
  527.         begin
  528.         Pressed:=true;
  529.         InvalidateRect(hWindow,nil,false);
  530.         end;
  531.     end
  532.  
  533. { if the mouse is moved out of the button area }
  534.  
  535. else if Pressed then
  536.     begin
  537.     Pressed:=false;
  538.     InvalidateRect(hWindow,nil,false);
  539.     end;
  540. end;
  541.  
  542. {************************************************************************
  543. *
  544. *    Name:            TCustomButton.WMSetFocus
  545. *
  546. *    Purpose:        Forces repaint if the focus is set to the button.
  547. *
  548. *    Parameters:    Msg - a message
  549. *
  550. *    Return:        None
  551. *
  552. ************************************************************************}
  553.  
  554. procedure TCustomButton.WMSetFocus(var Msg:TMessage);
  555. begin
  556. InvalidateRect(hWindow,nil,false);
  557. end;
  558.  
  559. {************************************************************************
  560. *
  561. *    Name:            TCustomButton.WMKillFocus
  562. *
  563. *    Purpose:        Forces repaint if the focus is taken away from the button.
  564. *
  565. *    Parameters:    Msg - a message
  566. *
  567. *    Return:        None
  568. *
  569. ************************************************************************}
  570.  
  571. procedure TCustomButton.WMKillFocus(var Msg:TMessage);
  572. begin
  573. InvalidateRect(hWindow,nil,false);
  574. end;
  575.  
  576. {************************************************************************
  577. *
  578. *    Name:            TCustomButton.WMKeyDown
  579. *
  580. *    Purpose:        Repaints the button in the down position if the space
  581. *                    bar is pressed on the button.
  582. *
  583. *    Parameters:    Msg - a message
  584. *
  585. *    Return:        None
  586. *
  587. ************************************************************************}
  588.  
  589. procedure TCustomButton.WMKeyDown(var Msg:Tmessage);
  590. begin
  591. if (Msg.wParam = $20) and not Pressed and not OwnMouse then
  592.     begin
  593.     Pressed:=true;
  594.     InvalidateRect(hWindow,nil,false);
  595.     end;
  596. end;
  597.  
  598. {************************************************************************
  599. *
  600. *    Name:            TCustomButton.WMKeyUp
  601. *
  602. *    Purpose:        Repaints the button in the up position and notifies the
  603. *                    parent window if the space bar is pressed on the button.
  604. *
  605. *    Parameters:    Msg - a message
  606. *
  607. *    Return:        None
  608. *
  609. ************************************************************************}
  610.  
  611. procedure TCustomButton.WMKeyUP(var Msg:Tmessage);
  612. begin
  613. if (Msg.wParam = $20) and Pressed and not OwnMouse then
  614.     begin
  615.     Pressed:=false;
  616.     InvalidateRect(hWindow,nil,false);
  617.     PostMessage(Parent^.hWindow,wm_Command,Attr.Id,longint(hWindow));
  618.     end;
  619. end;
  620.  
  621. {************************************************************************
  622. *
  623. *    Name:            TCustomButton.WMGetDlgCode
  624. *
  625. *    Purpose:        Gets whether or not the button is the default.
  626. *
  627. *    Parameters:    Msg - a message
  628. *
  629. *    Return:        None
  630. *
  631. ************************************************************************}
  632.  
  633. procedure TCustomButton.WMGetDlgCode(var Msg:Tmessage);
  634. begin
  635. if Default then
  636.     Msg.Result:=dlgc_DefPushButton
  637. else
  638.     Msg.Result:=dlgc_UndefPushButton;
  639. end;
  640.  
  641. {************************************************************************
  642. *
  643. *    Name:            TCustomButton.BMSetStyle
  644. *
  645. *    Purpose:        Sets the button style to either default or not.
  646. *
  647. *    Parameters:    Msg - a message
  648. *
  649. *    Return:        None
  650. *
  651. ************************************************************************}
  652.  
  653. procedure TCustomButton.BMSetStyle(var Msg:Tmessage);
  654. var    OldDefault:boolean;
  655. begin
  656. OldDefault:=Default;
  657. Default:=Msg.WParam = bs_DefPushButton;
  658. if Default <> OldDefault then
  659.     InvalidateRect(hWindow,nil,false);
  660. end;
  661.  
  662. {------------------------------------------------------------------------
  663. -------------------------------------------------------------------------
  664. ----                                    TBitButton Object                                ----
  665. -------------------------------------------------------------------------
  666. ------------------------------------------------------------------------}
  667.  
  668. {************************************************************************
  669. *
  670. *    Name:            TBitButton.Init
  671. *
  672. *    Purpose:        Initializes a button.
  673. *
  674. *    Parameters:    AParent        - parent window
  675. *                    AnID            - button ID
  676. *                    X,Y            - position
  677. *                    IsDefault    - default button ?
  678. *                    AUpName        - name of resource for up bitmap
  679. *                    AFocUpName    - name of resource for up bitmap when focused
  680. *                    ADownName    - name of resource for down bitmap
  681. *
  682. *    Return:        None
  683. *
  684. ************************************************************************}
  685.  
  686. constructor TBitButton.Init(AParent:PWindowsObject; AnID,X,Y:integer;
  687.                                         AUpName,AFocUpName,ADownName:PChar;
  688.                                         IsDefault:boolean);
  689. begin
  690. TCustomButton.Init(AParent,AnID,nil,X,Y,10,10,IsDefault);
  691.  
  692. UpName:=AUpName;
  693. FocUpName:=AFocUpName;
  694. DownName:=ADownName;
  695. end;
  696.  
  697. {************************************************************************
  698. *
  699. *    Name:            TBitButton.InitResource
  700. *
  701. *    Purpose:        Initializes a button from a resource.
  702. *
  703. *    Parameters:    AParent        - parent window
  704. *                    AnID            - button ID
  705. *                    AUpName        - name of resource for up bitmap
  706. *                    AFocUpName    - name of resource for up bitmap when focused
  707. *                    ADownName    - name of resource for down bitmap
  708. *
  709. *    Return:        None
  710. *
  711. ************************************************************************}
  712.  
  713. constructor TBitButton.InitResource(AParent:PWindowsObject; AnID:integer;
  714.                                         AUpName,AFocUpName,ADownName:PChar);
  715. begin
  716. TCustomButton.InitResource(AParent,AnID);
  717.  
  718. UpName:=AUpName;
  719. FocUpName:=AFocUpName;
  720. DownName:=ADownName;
  721. end;
  722.  
  723. {************************************************************************
  724. *
  725. *    Name:            TBitButton.Done
  726. *
  727. *    Purpose:        Destroys the button.
  728. *
  729. *    Parameters:    None
  730. *
  731. *    Return:        None
  732. *
  733. ************************************************************************}
  734.  
  735. destructor TBitButton.Done;
  736. begin
  737. DeleteObject(UpBits);
  738. DeleteObject(FocUpBits);
  739. DeleteObject(DownBits);
  740. TCustomButton.Done;
  741. end;
  742.  
  743. {************************************************************************
  744. *
  745. *    Name:            TBitButton.SetupWindow
  746. *
  747. *    Purpose:        Loads the bitmaps for a button, resizes the window
  748. *                    accordingly, and initializes the state variables.
  749. *
  750. *    Parameters:    None
  751. *
  752. *    Return:        None
  753. *
  754. ************************************************************************}
  755.  
  756. procedure TBitButton.SetupWindow;
  757. var    bm:TBitMap;
  758. begin
  759. TCustomButton.SetupWindow;
  760.  
  761. { load the bitmaps }
  762.  
  763. UpBits:=LoadBitmap(hInstance,UpName);
  764. FocUpBits:=LoadBitmap(hInstance,FocUpName);
  765. DownBits:=LoadBitmap(hInstance,DownName);
  766.  
  767. { resize the window to fit the bitmaps }
  768.  
  769. GetObject(DownBits,SizeOf(bm),@bm);
  770. MoveWindow(HWindow,Attr.X,Attr.Y,bm.bmWidth+2,bm.bmHeight+2,false);
  771. bmWidth:=bm.bmWidth;
  772. bmHeight:=bm.bmHeight;
  773. end;
  774.  
  775. {************************************************************************
  776. *
  777. *    Name:            TBitButton.GetClassName
  778. *
  779. *    Purpose:        Gets the class name for a bitmap button.
  780. *
  781. *    Parameters:    None
  782. *
  783. *    Return:        pointer to the class name
  784. *
  785. ************************************************************************}
  786.  
  787. function TBitButton.GetClassName;
  788. begin
  789. GetClassName:='BitButton';
  790. end;
  791.  
  792. {************************************************************************
  793. *
  794. *    Name:            TBitButton.Paint
  795. *
  796. *    Purpose:        Paints one of the bitmaps into the window depending on
  797. *                    the current state.
  798. *
  799. *    Parameters:    DC                - device context to paint into
  800. *                    PaintInfo    - painting information
  801. *
  802. *    Return:        None
  803. *
  804. ************************************************************************}
  805.  
  806. procedure TBitButton.Paint(DC:HDC; var PaintInfo:TPaintStruct);
  807. var    BitsDC:HDC;
  808.         OldBitmap:HBitMap;
  809.         OldBrush:HBrush;
  810. begin
  811.  
  812. { draw the border }
  813.  
  814. if Default then
  815.     OldBrush:=SelectObject(DC,GetStockObject(Black_Brush))
  816. else
  817.     OldBrush:=SelectObject(DC,GetStockObject(White_Brush));
  818. PatBlt(DC,0,0,Attr.W,1,PatCopy);
  819. PatBlt(DC,0,0,1,Attr.H,PatCopy);
  820. PatBlt(DC,0,Attr.H-1,Attr.W,1,PatCopy);
  821. PatBlt(DC,Attr.W-1,0,1,Attr.H,PatCopy);
  822. SelectObject(DC,OldBrush);
  823.  
  824. { draw the button }
  825.  
  826. BitsDC:=CreateCompatibleDC(DC);
  827. if Pressed then
  828.     OldBitmap:=SelectObject(BitsDC,DownBits)
  829. else if GetFocus = hWindow then
  830.     OldBitmap:=SelectObject(BitsDC,FocUpBits)
  831. else
  832.     OldBitmap:=SelectObject(BitsDC,UpBits);
  833. BitBlt(DC,1,1,bmWidth,bmHeight,BitsDC,0,0,SrcCopy);
  834. SelectObject(BitsDC,OldBitmap);
  835. DeleteDC(BitsDC);
  836. end;
  837.  
  838. {------------------------------------------------------------------------
  839. -------------------------------------------------------------------------
  840. ----                                    Unit initialization                            ----
  841. -------------------------------------------------------------------------
  842. ------------------------------------------------------------------------}
  843.  
  844. begin
  845. New(Customs,Init(40,10));
  846. end.
  847.